home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / action.scm next >
Encoding:
Text File  |  2010-11-07  |  18.0 KB  |  578 lines
  1. ;;; action.scm: Handles user-operable actions of input methods
  2. ;;;
  3. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  4. ;;;
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Redistribution and use in source and binary forms, with or without
  8. ;;; modification, are permitted provided that the following conditions
  9. ;;; are met:
  10. ;;; 1. Redistributions of source code must retain the above copyright
  11. ;;;    notice, this list of conditions and the following disclaimer.
  12. ;;; 2. Redistributions in binary form must reproduce the above copyright
  13. ;;;    notice, this list of conditions and the following disclaimer in the
  14. ;;;    documentation and/or other materials provided with the distribution.
  15. ;;; 3. Neither the name of authors nor the names of its contributors
  16. ;;;    may be used to endorse or promote products derived from this software
  17. ;;;    without specific prior written permission.
  18. ;;;
  19. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  20. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  21. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  23. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  25. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  26. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  27. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  28. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  29. ;;; SUCH DAMAGE.
  30. ;;;;
  31.  
  32. ;; This user-operable action handling framework have eliminated all of
  33. ;; property related handlings such as im-update-prop-list or
  34. ;; im-update-prop-label from each input method. Input method developer
  35. ;; can forget about the property (and legacy 'mode') feature except
  36. ;; for context creation process.
  37. ;;
  38. ;; The term 'widget' used in this framework is still under
  39. ;; discussion. It may be renamed in accordance with result of the
  40. ;; discussion.
  41. ;;
  42. ;; Input method developer must not use all procedures or records in
  43. ;; this file except for the 7 procedures described below. This is
  44. ;; required to ensure isolation of the property/action feature from
  45. ;; uim core. It is important for future extensibility and wide-range
  46. ;; platform support. Please satisfy following conditions.
  47.  
  48. ;; - Use only following 7 procedures.
  49. ;;   * register-action
  50. ;;   * register-widget
  51. ;;   * indicator-new
  52. ;;   * activity-indicator-new
  53. ;;   * actions-new
  54. ;;   * context-prop-activate-handler
  55. ;;   * context-mode-handler
  56. ;;
  57. ;; - Don't insert (require "action.scm") in your input method
  58. ;;   file. All necessary procedures described above are appropriately
  59. ;;   prepared in im.scm.
  60. ;;
  61. ;; - Name the widget used for choose input mode as
  62. ;;   "widget_*_input_mode" (replace "*" with your input method name
  63. ;;   such as "your_im"). This naming convention is used to display
  64. ;;   only the primary input state for user by some helper applets, or
  65. ;;   support a legacy 'mode' API.
  66. ;;
  67. ;; -- 2004-10-30 YamaKen
  68.  
  69. (require "util.scm")
  70.  
  71. ;;
  72. ;; action
  73. ;;
  74.  
  75. (define action-list ())
  76.  
  77. (define action-rec-spec
  78.   '((id                 #f)
  79.     (indication-handler #f)
  80.     (activity-pred      #f)
  81.     (handler            #f)))
  82. (define-record 'action action-rec-spec)
  83.  
  84. ;; indicator is restricted version of action
  85. (define indicator-rec-spec action-rec-spec)
  86. (define-record 'indicator indicator-rec-spec)
  87. (define indicator-set-id! #f)
  88. (define indicator-set-activity-pred! #f)
  89. (define indicator-set-activate-handler! #f)
  90. (define indicator-new-internal indicator-new)
  91. (define indicator-new
  92.   (lambda (indication-handler)
  93.     (indicator-new-internal #f indication-handler)))
  94.  
  95. ;; API for input method developers
  96. (define register-action
  97.   (lambda action
  98.     (set! action-list (alist-replace action action-list))))
  99.  
  100. (define fetch-action
  101.   (lambda (action-sym)
  102.     (assq action-sym action-list)))
  103.  
  104. (define action-active?
  105.   (lambda (action owner)
  106.     (let ((active? (action-activity-pred action)))
  107.       (and active?
  108.        (active? owner)))))
  109.  
  110. (define action-indicate
  111.   (lambda (action owner)
  112.     (let ((indicate (and action
  113.              (action-indication-handler action))))
  114.       (if indicate
  115.       (indicate owner)
  116.       fallback-indication))))
  117.  
  118. ;; API for input method developers
  119. (define actions-new
  120.   (lambda (action-syms)
  121.     (filter-map fetch-action action-syms)))
  122.  
  123. ;; API for input method developers
  124. (define activity-indicator-new
  125.   (lambda (action-syms)
  126.     (let ((actions (actions-new action-syms)))
  127.       (indicator-new
  128.        (lambda (owner)
  129.      (let ((active-action (find (lambda (action)
  130.                       (and action
  131.                        (action-active? action owner)))
  132.                       actions)))
  133.            (if active-action
  134.            (action-indicate active-action owner)
  135.            fallback-indication)))))))
  136.  
  137. ;;
  138. ;; widget
  139. ;;
  140.  
  141. (define widget-proto-list ())
  142.  
  143. (define widget-rec-spec
  144.   '((id          #f) ;; must be first member
  145.     (indicator   #f)
  146.     (actions     ())
  147.     (owner       #f)
  148.     (prev-config #f)
  149.     (prev-state  #f)))
  150. (define-record 'widget widget-rec-spec)
  151. (define widget-new-internal widget-new)
  152.  
  153. ;; API for input method developers
  154. (define register-widget
  155.   (lambda widget-proto
  156.     (let ((duplicated (copy-list widget-proto)))
  157.       (if (not (widget-actions duplicated))
  158.       (widget-set-actions! duplicated ()))
  159.       (set! widget-proto-list (alist-replace duplicated widget-proto-list)))))
  160.  
  161. (define widget-new
  162.   (lambda (wid owner)
  163.     (let ((widget-proto (assq wid widget-proto-list)))
  164.       (if widget-proto
  165.       (let* ((actions (widget-actions widget-proto))
  166.          (default-activity-sym (symbolconc 'default- wid))
  167.          (default-activity (and (symbol-bound? default-activity-sym)
  168.                     (assq (symbol-value
  169.                            default-activity-sym)
  170.                           actions)))
  171.          (init-list (append widget-proto
  172.                     (list owner)))
  173.          (widget (apply widget-new-internal init-list)))
  174.         (if default-activity
  175.         (widget-activate! widget default-activity))
  176.         widget)
  177.       #f))))
  178.  
  179. (define widget-activity
  180.   (lambda (widget)
  181.     (let* ((owner (widget-owner widget))
  182.        (active? (lambda (action)
  183.               (action-active? action owner)))
  184.        (candidates (filter active?
  185.                    (widget-actions widget))))
  186.       (cond
  187.        ((= (length candidates)
  188.        1)
  189.     (car candidates))
  190.        ((null? candidates)
  191.     #f)
  192.        (else
  193.     (if (>= (verbose)
  194.         5)
  195.         (print (widget-debug-message widget
  196.                      "widget-activity"
  197.                      "ambiguous activity")))
  198.     #f)))))
  199.  
  200. ;; 'action' accepts both actual action or action-id
  201. (define widget-activate!
  202.   (lambda (widget action)
  203.     (let* ((action (if (symbol? action)
  204.                (assq action (widget-actions widget))
  205.                action))
  206.        (handler (and action
  207.              (action-handler action))))
  208.       (and handler
  209.        (begin
  210.          (handler (widget-owner widget))
  211.          #t)))))
  212.  
  213. (define widget-configuration
  214.   (lambda (widget)
  215.     (let* ((owner (widget-owner widget))
  216.        (indicator (widget-indicator widget))
  217.        (indicate (lambda (action)
  218.                (action-indicate action owner))))
  219.       (cons (or (and indicator
  220.              (indicator-id indicator))
  221.         'action_unknown)
  222.         (map indicate
  223.          (widget-actions widget))))))
  224.  
  225. (define widget-state
  226.   (lambda (widget)
  227.     (let* ((activity (widget-activity widget))
  228.        (owner (widget-owner widget))
  229.        (indicator (widget-indicator widget))
  230.        (indicator-indication (action-indicate indicator owner)))
  231.       (list activity indicator-indication))))
  232.  
  233. (define widget-update-configuration!
  234.   (lambda (widget)
  235.     (let* ((new-config (widget-configuration widget))
  236.        (config-updated? (not (equal? (widget-prev-config widget)
  237.                      new-config))))
  238.       (widget-set-prev-config! widget new-config)
  239.       config-updated?)))
  240.  
  241. (define widget-update-state!
  242.   (lambda (widget)
  243.     (let* ((new-state (widget-state widget))
  244.        (state-updated? (not (equal? (widget-prev-state widget)
  245.                     new-state))))
  246.       (widget-set-prev-state! widget new-state)
  247.       state-updated?)))
  248.  
  249. (define widget-debug-message
  250.   (lambda (widget location defect)
  251.     (let* ((wid (widget-id widget))
  252.        (widget-id-str (symbol->string wid)))
  253.       (string-append
  254.        defect " in " location ". debug " widget-id-str "."))))
  255.  
  256. ;;
  257. ;; helper protocol message handlings
  258. ;;
  259.  
  260. ;; See doc/HELPER-PROTOCOL for the protocol specification
  261.  
  262. (define indication-compose-label
  263.   (lambda (indication)
  264.     (string-append (symbol->string (indication-id indication)) "\t"
  265.            (indication-iconic-label indication) "\t"
  266.            (indication-label indication) "\n")))
  267.  
  268. (define indication-compose-branch
  269.   (lambda (indication)
  270.     (string-append "branch\t"
  271.            (indication-compose-label indication))))
  272.  
  273. (define indication-compose-leaf
  274.   (lambda (indication act-id active?)
  275.     (string-append "leaf\t"
  276.            (symbol->string (indication-id indication)) "\t"
  277.            (indication-iconic-label indication) "\t"
  278.            (indication-label indication) "\t"
  279.            (indication-short-desc indication) "\t"
  280.            (symbol->string act-id) "\t"
  281.            (if active?
  282.                "*\n"
  283.                "\n"))))
  284.  
  285. (define widget-compose-live-branch
  286.   (lambda (widget)
  287.     (let* ((owner (widget-owner widget))
  288.        (activity (widget-activity widget))
  289.        (indicator (widget-indicator widget))
  290.        (branch (indication-compose-branch (action-indicate indicator owner)))
  291.        (leaves (map (lambda (action)
  292.               (let ((active? (eq? action activity))
  293.                 (indication (action-indicate action owner))
  294.                 (act-id (action-id action)))
  295.                 (indication-compose-leaf indication act-id active?)))
  296.             (widget-actions widget))))
  297.       (apply string-append (cons branch leaves)))))
  298.  
  299. ;; API for uim developers
  300. ;;
  301. ;; Developers must use this procedure to reconfigure order or
  302. ;; existence of widgets. Don't use context-set-widgets! directly. The
  303. ;; framework can't detect the configuration information invalidation
  304. ;; when violently reconfigured by context-set-widgets!.
  305. (define context-init-widgets!
  306.   (lambda (context widget-id-list)
  307.     (let* ((widget-id-list (if (or (null? widget-id-list)
  308.                    (not widget-id-list))
  309.                    '(widget_fallback)
  310.                    widget-id-list))
  311.        (widgets (filter-map (lambda (wid)
  312.                   (if (symbol? wid)
  313.                       (widget-new wid context)
  314.                       wid)) ;; already actualized
  315.                 widget-id-list)))
  316.       (context-set-widgets! context widgets)
  317.       (context-propagate-widget-configuration context))))
  318.  
  319. ;; TODO: write test
  320. ;; API for uim developers
  321. (define context-list-replace-widgets!
  322.   (lambda (target-im-name widget-id-list)
  323.     (for-each (lambda (context)
  324.         (let* ((im (context-im context))
  325.                (name (im-name im)))
  326.           (and (eq? name
  327.                 target-im-name)
  328.                (context-init-widgets! context widget-id-list))))
  329.           context-list)))
  330.  
  331. ;; API for uim developers
  332. ;; returns action-id list that can be passed to context-update-widget-states!
  333. ;; TODO: write test
  334. (define context-current-widget-states
  335.   (let ((widget-act-id (compose action-id widget-activity)))
  336.     (lambda (context)
  337.       (map widget-act-id (context-widgets context)))))
  338.  
  339. ;; API for uim developers
  340. ;; TODO: write test
  341. (define context-update-widget-states!
  342.   (lambda (context act-ids)
  343.     (for-each widget-activate!
  344.           (context-widgets context)
  345.           act-ids)))
  346.  
  347. ;; API for uim developers
  348. (define context-update-widgets
  349.   (lambda (context)
  350.     (let ((widgets (context-widgets context)))
  351.       (if (not (null? (filter-map widget-update-configuration! widgets)))
  352.           (context-propagate-widget-configuration context))
  353.       (if (not (null? (filter-map widget-update-state! widgets)))
  354.           (context-propagate-widget-states context)))))
  355.  
  356. (define context-propagate-prop-list-update
  357.   (lambda (context)
  358.     (let* ((widgets (context-widgets context))
  359.        (branches (map widget-compose-live-branch
  360.               widgets))
  361.        (widget-config-tree (apply string-append branches)))
  362.       (im-update-prop-list context widget-config-tree))))
  363.  
  364. ;; API for uim developers
  365. (define context-propagate-widget-states
  366.   (lambda (context)
  367.     ;; Sending prop_list every time costs all uim participant
  368.     ;; processes slightly heavy resource consumptions. Although it is
  369.     ;; not a problem for the rich desktop environment today, we should
  370.     ;; also consider resource sensitive embedded environments if it is
  371.     ;; not hard.
  372.     ;;
  373.     ;; We should adopt another message to send lightweight status
  374.     ;; update, and revise prop_list as initial configuration message
  375.     ;; (i.e. remove the flag field) -- 2004-10-08 YamaKen
  376.     (context-propagate-prop-list-update context)
  377.     (context-update-mode context)))
  378.  
  379. ;; API for uim developers
  380. (define context-propagate-widget-configuration
  381.   (lambda (context)
  382.     (context-propagate-prop-list-update context)
  383.     (context-update-mode-list context)))
  384.  
  385. ;; API for input method developers
  386. ;; ready to use for register-im
  387. (define context-prop-activate-handler
  388.   (lambda (context message)
  389.     (let* ((widgets (context-widgets context))
  390.        (act-id (string->symbol message))
  391.        (activate! (lambda (widget)
  392.             (let* ((actions (widget-actions widget))
  393.                    (action (assq act-id actions))
  394.                    (indicator (widget-indicator widget)))
  395.               (or (widget-activate! widget action)
  396.                   (widget-activate! widget indicator))))))
  397.       (find activate! widgets))))
  398.  
  399.  
  400. ;;
  401. ;; legacy 'mode' handlings for backward compatibility
  402. ;;
  403.  
  404. ;; find the property that has "_input_mode" suffix
  405. (define context-find-mode-widget
  406.   (lambda (context)
  407.     (let* ((widgets (context-widgets context))
  408.        (extract-suffix (lambda (widget)
  409.                  (let* ((wid (widget-id widget))
  410.                     (as-str (symbol->string wid))
  411.                     (rev-words (reverse
  412.                         (string-split as-str "_"))))
  413.                    (and (>= (length rev-words) 2)
  414.                     (list-head rev-words 2)))))
  415.        (mode-widget? (lambda (widget)
  416.                (let ((suffix (extract-suffix widget)))
  417.                  (equal? suffix
  418.                      '("mode" "input"))))))
  419.       (find mode-widget? widgets))))
  420.  
  421. (define widget-action-id->mode-value
  422.   (lambda (mode-widget aid)
  423.     (let ((index (lambda (val lst)
  424.            (let ((found (memq val (reverse lst))))
  425.              (if found
  426.              (- (length found)
  427.                 1)
  428.              (error "invalid action-id for mode-widget")))))
  429.       (act-ids (map action-id
  430.             (widget-actions mode-widget))))
  431.       (index aid act-ids))))
  432.  
  433. (define widget-mode-value->action-id
  434.   (lambda (mode-widget mode)
  435.     (let* ((actions (widget-actions mode-widget))
  436.        (act-ids (map action-id actions)))
  437.       (and (>= mode
  438.            0)
  439.        (< mode
  440.           (length actions))
  441.        (nth mode act-ids)))))
  442.  
  443. (define context-current-mode
  444.   (lambda (context)
  445.     (let* ((mode-widget (context-find-mode-widget context))
  446.        (activity (and mode-widget
  447.               (widget-activity mode-widget))))
  448.       (if activity
  449.       (widget-action-id->mode-value mode-widget
  450.                     (action-id activity))
  451.       0))))
  452.  
  453. ;; don't invoke directly. use context-propagate-widget-states instead
  454. (define context-update-mode
  455.   (lambda (context)
  456.     (im-update-mode context (context-current-mode context))))
  457.  
  458. ;; don't invoke directly. use context-propagate-widget-configuration instead
  459. (define context-update-mode-list
  460.   (lambda (context)
  461.     (im-clear-mode-list context)
  462.     (let ((mode-widget (context-find-mode-widget context)))
  463.       (if mode-widget
  464.       (for-each (lambda (action)
  465.               (let* ((indication (action-indicate action context))
  466.                  (label (indication-label indication)))
  467.             (im-pushback-mode-list context label)))
  468.             (widget-actions mode-widget))
  469.       (im-pushback-mode-list context
  470.                  (indication-label fallback-indication))))
  471.     (im-update-mode-list context)
  472.     (context-update-mode context)))
  473.  
  474. ;; API for input method developers
  475. ;; ready to use for register-im
  476. (define context-mode-handler
  477.   (lambda (context mode)
  478.     (let* ((mode-widget (context-find-mode-widget context))
  479.        (act-id (and mode-widget
  480.                (widget-mode-value->action-id mode-widget mode))))
  481.       (and act-id
  482.        (widget-activate! mode-widget act-id)))))
  483.  
  484. ;;
  485. ;; builtin entities
  486. ;;
  487.  
  488. (define fallback-indication
  489.   (list 'unknown
  490.     "?"
  491.     (N_ "unknown")
  492.     (N_ "unknown")))
  493.  
  494. (register-widget
  495.  'widget_fallback
  496.  (indicator-new (lambda (owner)
  497.           fallback-indication))
  498.  #f) ;; has no actions
  499.  
  500. ;; should be replaced with real separator by helper tool implementations
  501. (register-action 'action_separator
  502.          (list 'separator ;; dummy indication
  503.                "--"
  504.                "--------"
  505.                "")
  506.          #f  ;; has no activity
  507.          #f) ;; has no handler
  508.  
  509.  
  510. ;;
  511. ;; widget definitions for example
  512. ;;
  513.  
  514. ;;; user configs
  515.  
  516. ;; controls:
  517. ;; - what widgets will be shown for user
  518. ;; - shown in what order
  519. (define test-widgets '(;;widget_example_im_name
  520.                ;;widget_example_exec_im_switcher
  521.                ;;widget_example_arbitrary_info
  522.                ;;widget_example_non_selectable_item
  523.                ))
  524.  
  525. ;;; internal definitions
  526.  
  527. (define example-im-name-indication
  528.   (list 'im_name_example
  529.     "example"
  530.     "example (ja)"
  531.     (N_ "Japanese Kana Kanji Conversion Engine, Example")))
  532.  
  533. (define example-exec-im-switcher-indication
  534.   (list 'im_switcher
  535.     "sw"
  536.     (N_ "exec im-switcher")
  537.     (N_ "exec im-switcher")))
  538.  
  539. (register-action 'action_exec_im_switcher
  540.          (lambda (ac)
  541.            example-exec-im-switcher-indication)
  542.          #f ;; has no activity
  543.          (lambda (ac)
  544.            (print "exec uim-im-switcher")))
  545.  
  546. ;; Update widget definitions based on action configurations. The
  547. ;; procedure is needed for on-the-fly reconfiguration involving the
  548. ;; custom API
  549. (define example-configure-widgets
  550.   (lambda ()
  551.     (register-widget 'widget_example_im_name
  552.              (indicator-new (lambda (ac)
  553.                       example-im-name-indication))
  554.              #f) ;; has no actions
  555.  
  556.     (register-widget 'widget_example_arbitrary_info
  557.              (indicator-new (let ((count 0))
  558.                       (lambda (ac)
  559.                     (set! count (+ count 1))
  560.                     (list (digit->string count)
  561.                           "an arbitrary information"
  562.                           "an arbitrary information"))))
  563.              ;; indicator and actions are isolated
  564.              (actions-new example-input-mode-actions))
  565.  
  566.     ;; requires revised protocol message to activate indicator button
  567.     (register-widget 'widget_example_exec_im_switcher
  568.              ;; indicator can be an action
  569.              (fetch-action 'action_exec_im_switcher)
  570.              #f) ;; has no actions
  571.  
  572.     ;; actions can contain non-selectable but activatable item
  573.     ;; (exec-im-switcher)
  574.     (register-widget 'widget_example_non_selectable_item
  575.              (activity-indicator-new example-input-mode-actions)
  576.              (actions-new (cons 'action_exec_im_switcher
  577.                     example-input-mode-actions)))))
  578.